home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / perl / msds-prl / bcdsprl1.zoo / lib / newgetop.pl < prev    next >
Perl Script  |  1991-11-13  |  6KB  |  208 lines
  1. # newgetopt.pl -- new options parsing
  2.  
  3. # SCCS Status     : @(#)@ newgetopt.pl    1.8
  4. # Author          : Johan Vromans
  5. # Created On      : Tue Sep 11 15:00:12 1990
  6. # Last Modified By: Johan Vromans
  7. # Last Modified On: Thu Sep 26 20:10:41 1991
  8. # Update Count    : 35
  9. # Status          : Okay
  10.  
  11. # This package implements a new getopt function. This function adheres
  12. # to the new syntax (long option names, no bundling).
  13. #
  14. # Arguments to the function are:
  15. #
  16. #  - a list of possible options. These should designate valid perl
  17. #    identifiers, optionally followed by an argument specifier ("="
  18. #    for mandatory arguments or ":" for optional arguments) and an
  19. #    argument type specifier: "n" or "i" for integer numbers, "f" for
  20. #    real (fix) numbers or "s" for strings.
  21. #
  22. #  - if the first option of the list consists of non-alphanumeric
  23. #    characters only, it is interpreted as a generic option starter.
  24. #    Everything starting with one of the characters from the starter
  25. #    will be considered an option.
  26. #    Likewise, a double occurrence (e.g. "--") signals end of
  27. #    the options list.
  28. #    The default value for the starter is "-".
  29. #
  30. # Upon return, the option variables, prefixed with "opt_", are defined
  31. # and set to the respective option arguments, if any.
  32. # Options that do not take an argument are set to 1. Note that an
  33. # option with an optional argument will be defined, but set to '' if
  34. # no actual argument has been supplied.
  35. # A return status of 0 (false) indicates that the function detected
  36. # one or more errors.
  37. #
  38. # Special care is taken to give a correct treatment to optional arguments.
  39. #
  40. # E.g. if option "one:i" (i.e. takes an optional integer argument),
  41. # then the following situations are handled:
  42. #
  43. #    -one -two        -> $opt_one = '', -two is next option
  44. #    -one -2        -> $opt_one = -2
  45. #
  46. # Also, assume "foo=s" and "bar:s" :
  47. #
  48. #    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  49. #    -foo -bar        -> $opt_foo = '-bar'
  50. #    -foo --        -> $opt_foo = '--'
  51. #
  52.  
  53. # HISTORY 
  54. # 20-Sep-1990        Johan Vromans    
  55. #    Set options w/o argument to 1.
  56. #    Correct the dreadful semicolon/require bug.
  57.  
  58.  
  59. package newgetopt;
  60.  
  61. $debug = 0;            # for debugging
  62.  
  63. sub main'NGetOpt {
  64.     local (@optionlist) = @_;
  65.     local ($[) = 0;
  66.     local ($genprefix) = "-";
  67.     local ($error) = 0;
  68.     local ($opt, $optx, $arg, $type, $mand, @hits);
  69.  
  70.     # See if the first element of the optionlist contains option
  71.     # starter characters.
  72.     $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
  73.  
  74.     # Turn into regexp.
  75.     $genprefix =~ s/(\W)/\\\1/g;
  76.     $genprefix = "[" . $genprefix . "]";
  77.  
  78.     # Verify correctness of optionlist.
  79.     @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
  80.     if ( $#hits >= 0 ) {
  81.     foreach $opt ( @hits ) {
  82.         print STDERR ("Error in option spec: \"", $opt, "\"\n");
  83.         $error++;
  84.     }
  85.     return 0;
  86.     }
  87.  
  88.     # Process argument list
  89.  
  90.     while ( $#main'ARGV >= 0 ) {        #'){
  91.  
  92.     # >>> See also the continue block <<<
  93.  
  94.     # Get next argument
  95.     $opt = shift (@main'ARGV);        #');
  96.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  97.     $arg = undef;
  98.  
  99.     # Check for exhausted list.
  100.     if ( $opt =~ /^$genprefix/o ) {
  101.         # Double occurrence is terminator
  102.         return ($error == 0) if $opt eq "$+$+";
  103.         $opt = $';        # option name (w/o prefix)
  104.     }
  105.     else {
  106.         # Apparently not an option - push back and exit.
  107.         unshift (@main'ARGV, $opt);        #');
  108.         return ($error == 0);
  109.     }
  110.  
  111.     # Grep in option list. Hide regexp chars from option.
  112.     ($optx = $opt) =~ s/(\W)/\\\1/g;
  113.     @hits = grep (/^$optx([=:].+)?$/, @optionlist);
  114.     if ( $#hits != 0 ) {
  115.         print STDERR ("Unknown option: ", $opt, "\n");
  116.         $error++;
  117.         next;
  118.     }
  119.  
  120.     # Determine argument status.
  121.     undef $type;
  122.     $type = $+ if $hits[0] =~ /[=:].+$/;
  123.     print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
  124.  
  125.     # If it is an option w/o argument, we're almost finished with it.
  126.     if ( ! defined $type ) {
  127.         $arg = 1;        # supply explicit value
  128.         next;
  129.     }
  130.  
  131.     # Get mandatory status and type info.
  132.     ($mand, $type) = $type =~ /^(.)(.)$/;
  133.  
  134.     # Check if the argument list is exhausted.
  135.     if ( $#main'ARGV < 0 ) {        #'){
  136.  
  137.         # Complain if this option needs an argument.
  138.         if ( $mand eq "=" ) {
  139.         print STDERR ("Option ", $opt, " requires an argument\n");
  140.         $error++;
  141.         }
  142.         if ( $mand eq ":" ) {
  143.         $arg = $type eq "s" ? "" : 0;
  144.         }
  145.         next;
  146.     }
  147.  
  148.     # Get (possibly optional) argument.
  149.     $arg = shift (@main'ARGV);        #');
  150.  
  151.     # Check if it is a valid argument. A mandatory string takes
  152.      # anything. 
  153.     if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
  154.  
  155.         # Check for option list terminator.
  156.         if ( $arg eq "$+$+" ) {
  157.         # Complain if an argument is required.
  158.         if ($mand eq "=") {
  159.             print STDERR ("Option ", $opt, " requires an argument\n");
  160.             $error++;
  161.         }
  162.         # Push back so the outer loop will terminate.
  163.         unshift (@main'ARGV, $arg);    #');
  164.         $arg = "";    # don't assign it
  165.         next;
  166.         }
  167.  
  168.         # Maybe the optional argument is the next option?
  169.         if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
  170.         # Yep. Push back.
  171.         unshift (@main'ARGV, $arg);    #');
  172.         $arg = "";    # don't assign it
  173.         next;
  174.         }
  175.     }
  176.  
  177.     if ( $type eq "n" || $type eq "i" ) { # numeric/integer
  178.         if ( $arg !~ /^-?[0-9]+$/ ) {
  179.         print STDERR ("Value \"", $arg, "\" invalid for option ",
  180.                    $opt, " (numeric required)\n");
  181.         $error++;
  182.         }
  183.         next;
  184.     }
  185.  
  186.     if ( $type eq "f" ) { # fixed real number, int is also ok
  187.         if ( $arg !~ /^-?[0-9.]+$/ ) {
  188.         print STDERR ("Value \"", $arg, "\" invalid for option ",
  189.                    $opt, " (real number required)\n");
  190.         $error++;
  191.         }
  192.         next;
  193.     }
  194.  
  195.     if ( $type eq "s" ) { # string
  196.         next;
  197.     }
  198.  
  199.     }
  200.     continue {
  201.     print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
  202.     eval ("\$main'opt_$opt = \$arg");
  203.     }
  204.  
  205.     return ($error == 0);
  206. }
  207. 1;
  208.